home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog6.arj / MENUBITS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  4.1 KB  |  166 lines
  1. { menubits.pas -- Create menu items from bitmaps }
  2.  
  3. program MenuBits;
  4.  
  5. {$R menubits.res}
  6.  
  7. uses WinTypes, WinProcs, WObjects;
  8.  
  9. const
  10.  
  11.   id_Menu   = 100;         { Menu resource ID }
  12.   cm_Quit   = 101;         { Exit command ID }
  13.   num_Items = 9;           { Number of custom menu items }
  14.  
  15. type
  16.  
  17.   MenuBitsApplication = object(TApplication)
  18.     procedure InitMainWindow; virtual;
  19.   end;
  20.  
  21.   MenuItemRec = record
  22.     Name: String[20];      { Text for menu item }
  23.     BMap: HBitmap;         { Handle to item's bitmap }
  24.     CommandID: Integer     { ID returned for command }
  25.   end;
  26.  
  27.   PMenuBitsWindow = ^MenuBitsWindow;
  28.   MenuBitsWindow = object(TWindow)
  29.     MenuItems: array[0 .. num_Items - 1] of MenuItemRec;
  30.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  31.     destructor Done;
  32.       virtual;
  33.     procedure InitMenuItems;
  34.     procedure MakeBitmaps;
  35.     procedure SetupWindow;
  36.       virtual;
  37.     procedure CMQuit(var Msg: TMessage);
  38.       virtual cm_First + cm_Quit;
  39.   end;
  40.  
  41.  
  42. { MenuBitsApplication }
  43.  
  44. {- Initialize MenuBitsApplication object's window }
  45. procedure MenuBitsApplication.InitMainWindow;
  46. begin
  47.   MainWindow := New(PMenuBitsWindow, Init(nil, 'MenuBits'))
  48. end;
  49.  
  50.  
  51. { MenuBitsWindow }
  52.  
  53. {- Construct MenuBitsWindow object; load bitmap resources }
  54. constructor MenuBitsWindow.Init(AParent: PWindowsObject;
  55.   ATitle: PChar);
  56. begin
  57.   TWindow.Init(AParent, ATitle);
  58.   Attr.Menu := LoadMenu(HInstance, PChar(id_Menu));
  59.   InitMenuItems
  60. end;
  61.  
  62. {- Destroy MenuBitsWindow; delete bitmaps }
  63. destructor MenuBitsWindow.Done;
  64. var
  65.   I: Integer;
  66. begin
  67.   for I := 0 to num_Items - 1 do
  68.     DeleteObject(MenuItems[I].Bmap);
  69.   TWindow.Done
  70. end;
  71.  
  72. {- Attach bitmaps to menu }
  73. procedure MenuBitsWindow.SetupWindow;
  74. var
  75.   I: Integer;
  76.   Mh: HMenu;
  77. begin
  78.   MakeBitmaps;
  79.   Mh := CreatePopupMenu;
  80.   if Mh <> 0 then
  81.   begin
  82.     AppendMenu(Attr.Menu, mf_Popup, Mh, '&Bitmaps');
  83.     for I := 0 to num_Items - 1 do with MenuItems[I] do
  84.       AppendMenu(Mh, mf_Bitmap, CommandID, PChar(MakeLong(Bmap, 0)))
  85.   end;
  86.   DrawMenubar(HWindow)
  87. end;
  88.  
  89. {- Initialize MenuItems array (bitmaps created later) }
  90. procedure MenuBitsWindow.InitMenuItems;
  91. var
  92.   I: Integer;
  93.   S: string[5];
  94. begin
  95.   for I := 0 to num_Items - 1 do with MenuItems[I] do
  96.   begin
  97.     Str(I + 1, S);
  98.     Name := 'Menu item #' + S;
  99.     CommandID := 201 + I
  100.   end
  101. end;
  102.  
  103. {- Create menu-item bitmaps }
  104. procedure MenuBitsWindow.MakeBitmaps;
  105. var
  106.   I: Integer;
  107.   Dc, MemDC: HDC;
  108.   OldBitmap: HBitmap;
  109.   FillBrush: HBrush;
  110.   R: TRect;
  111.   MenuFont, OldFont: HFont;
  112.   N: LongInt;
  113. begin
  114.   Dc := GetDC(HWindow);
  115.   MemDC := CreateCompatibleDC(Dc);
  116.   FillBrush := CreateSolidBrush(GetSysColor(color_Menu));
  117.   SetTextColor(MemDC, GetSysColor(color_MenuText));
  118.   SetBkColor(MemDC, GetSysColor(color_Menu));
  119.   MenuFont := GetStockObject(ansi_Var_Font);
  120.   OldFont := SelectObject(MemDC, MenuFont);
  121.   with R do
  122.   begin
  123.     Left := 0; Top := 0; Right := -1; Bottom := -1;
  124.     for I := 0 to num_Items - 1 do with MenuItems[I] do
  125.     begin
  126.       N := GetTextExtent(MemDC, @Name[1], Length(Name));
  127.       if LOWORD(N) > Right then Right := LOWORD(N);
  128.       if HIWORD(N) > Bottom then Bottom := HIWORD(N)
  129.     end;
  130.     for I := 0 to num_Items - 1 do with MenuItems[I] do
  131.     begin
  132.       Bmap := CreateCompatibleBitmap(Dc, Right, Bottom);
  133.       OldBitmap := SelectObject(MemDC, Bmap);
  134.       FillRect(MemDC, R, FillBrush);
  135.       TextOut(MemDC, 0, 0, @Name[1], Length(Name));
  136.       Bmap := SelectObject(MemDC, OldBitmap)
  137.     end;
  138.   end;
  139.   SelectObject(MemDC, OldFont);
  140.   DeleteDC(MemDC);
  141.   ReleaseDC(HWindow, Dc);
  142.   DeleteObject(FillBrush)
  143. end;
  144.  
  145. {- End program when Exit command is selected }
  146. procedure MenuBitsWindow.CMQuit(var Msg: TMessage);
  147. begin
  148.   CloseWindow
  149. end;
  150.  
  151. var
  152.  
  153.   MenuBitsApp: MenuBitsApplication;
  154.  
  155. begin
  156.   MenuBitsApp.Init('MenuBitsApp');
  157.   MenuBitsApp.Run;
  158.   MenuBitsApp.Done
  159. end.
  160.  
  161.  
  162. {--------------------------------------------------------------
  163.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  164.   Revision 1.00    Date: 2/26/1991
  165. ---------------------------------------------------------------}
  166.